home *** CD-ROM | disk | FTP | other *** search
/ Delphi Developer's Kit 1996 / Delphi Developer's Kit 1996.iso / power / chrono / panclock.pas < prev    next >
Pascal/Delphi Source File  |  1995-12-22  |  15KB  |  451 lines
  1. {$A+,B-,D+,F-,G+,I+,K+,L+,N+,P+,Q-,R-,S-,T-,V+,W-,X+,Y+}
  2. {$M 16384,8192}
  3. {*****************************************************************************}
  4. {                                                                             }
  5. { TPanelClock - a VCL component that is provides time-of-date, NUM, CAPS, and }
  6. {   Scroll Key Statuses. When you click on this component (at run-time), it   }
  7. {   will switch to showing free GDI, System, and User Resources. Source code  }
  8. {   documentation is rather limited, with the exception of the rather arcane  }
  9. {   properties which as described below. This component (such as it is) is    }
  10. {   hereby given to the public domain. Should you find it useful at some      }
  11. {   point in your programming career, please feel obligated to donate one of  }
  12. {   your own equally useful components to the public domain. If you have any  }
  13. {   suggestions for improvements, or if you find any bugs, please notify the  }
  14. {   author (but please be gentle - this is my first component). Thank-you.    }
  15. {                                                                             }
  16. {  Author: Cameron D. Peters                                                  }
  17. {          Suite 311, 908 - 17th Avenue S.W.                                  }
  18. {          Calgary, Alberta CANADA                                            }
  19. {          CIS: 72561,3146                                                    }
  20. {          Phone: 403-228-9991                                                }
  21. {          Fax: 403-228-0202                                                  }
  22. {                                                                             }
  23. {  Revision History:                                                          }
  24. {    1.00  CDP  950525  Created                                               }
  25. {                                                                             }
  26. {  Installation                                                               }
  27. {    Use Tools|Install Components to add this to your VCL. TPanelClock will   }
  28. {    be added to the additional page of your component palette.               }
  29. {                                                                             }
  30. {  Properties                                                                 }
  31. {    I haven't created an on-line help file for this component, because I     }
  32. {    don't really have the time, or possibly because I am just lazy. Perhaps  }
  33. {    I'll create one if enough people download this file as it is! Anyways,   }
  34. {    here are my notes on the properties which were not inherited (in no      }
  35. {    particular order):                                                       }
  36. {                                                                             }
  37. {    PanelMode - can be pmClock or pmResources. When it's pmClock, the        }
  38. {      component shows the time-of-day, and the status of NUM, CAPS, and      }
  39. {      SCRL. When it's pmResources, it will show the percentage of free       }
  40. {      GDI, USER and System Resources.                                        }
  41. {    AllowClick - when this is true, the user can click on the component      }
  42. {      to switch back and forth between the clock and the resource monitor.   }
  43. {    AlertLevel - if any of the resources fall below this level, they will    }
  44. {      be shown using the AlertFont.                                          }
  45. {    AlertFont - font used to display resources which have fallen below the   }
  46. {      AlertLevel.                                                            }
  47. {    AlertMatchFont - when this is true, the AlertFont will be made to match  }
  48. {      the Font, with the exception that the color of the AlertFont will be   }
  49. {      set to clRed.                                                          }
  50. {    Spaces - the number of pixels of space between sections of the panel.    }
  51. {    ClockWidth - the width of the clock in pixels.                           }
  52. {                                                                             }
  53. {*****************************************************************************}
  54.  
  55. unit PanClock;
  56.  
  57. interface
  58.  
  59. uses
  60.   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  61.   Forms, Dialogs, ExtCtrls;
  62.  
  63. const
  64.   {Key statuses}
  65.   ksNumberOfKeyStatuses = 3;
  66.   ksNumLock = 1;
  67.   ksCapsLock = 2;
  68.   ksScrollLock = 4;
  69.  
  70.   {Resource Monitors}
  71.   rmNumberOfMonitors = 3;
  72.   rmGDIResources = 1;
  73.   rmSystemResources = 2;
  74.   rmUserResources = 3;
  75.  
  76. type
  77.   TResourceMonitor = array[rmGDIResources..rmUserResources] of integer;
  78.   TPanelMode = (pmClock,pmResources);
  79.   TPanelClock = class(TCustomControl)
  80.   private
  81.     { Private declarations }
  82.     FAlertFont: TFont;
  83.     FAlertLevel: Integer;
  84.     FAlertMatchFont: Boolean;
  85.     FAllowClick: Boolean;
  86.     FBevel: TPanelBevel;
  87.     FBevelWidth: Integer;
  88.     FClockWidth: Integer;
  89.     FHint2: String;
  90.     FKeyState: Integer;
  91.     FLastPaint: String[20];
  92.     FPanelMode: TPanelMode;
  93.     FSpace: Integer;
  94.     FResources: TResourceMonitor;
  95.   protected
  96.     { Protected declarations }
  97.     procedure Click; override;
  98.     procedure Paint; override;
  99.     procedure SetAlertFont(Value: TFont);
  100.     procedure SetAlertLevel(Value: Integer);
  101.     procedure SetAlertMatchFont(Value: Boolean);
  102.     procedure SetBevel(Value: TPanelBevel);
  103.     procedure SetBevelWidth(Value: Integer);
  104.     procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
  105.     procedure SetClockWidth(Value: Integer);
  106.     procedure SetPanelMode(Value: TPanelMode);
  107.     procedure SetSpace(Value: Integer);
  108.     procedure WMDestroy(var Msg: TMsg); message WM_Destroy;
  109.     procedure WMCreate(var Msg: TMsg); message WM_Create;
  110.     procedure WMTimer(var Msg: TMsg); message WM_Timer;
  111.   public
  112.     { Public declarations }
  113.     constructor Create(AOwner: TComponent); override;
  114.   published
  115.     { Published declarations }
  116.     property AlertFont: TFont read FAlertFont write SetAlertFont;
  117.     property AlertLevel: Integer read FAlertLevel write SetAlertLevel default 20;
  118.     property AlertMatchFont: Boolean read FAlertMatchFont write SetAlertMatchFont default TRUE;
  119.     property Align;
  120.     property AllowClick: Boolean read FAllowClick write FAllowClick default TRUE;
  121.     property Bevel: TPanelBevel read FBevel write SetBevel default bvLowered;
  122.     property BevelWidth: Integer read FBevelWidth write SetBevelWidth default 1;
  123.     property ClockWidth: Integer read FClockWidth write SetClockWidth default 96;
  124.     property Color;
  125.     property Enabled;
  126.     property Font;
  127.     property Height default 16;
  128.     property Hint;
  129.     property Hint2: String read FHint2 write FHint2;
  130.     property PanelMode: TPanelMode read FPanelMode write SetPanelMode default pmClock;
  131.     property ParentColor;
  132.     property ParentFont;
  133.     property ParentShowHint;
  134.     property ShowHint;
  135.     property Space: Integer read FSpace write SetSpace default 1;
  136.     property Width default 219;
  137.   end;
  138.  
  139. procedure Register;
  140.  
  141. implementation
  142.  
  143.  
  144. function IntFindMin(X,Y: Integer): Integer;
  145.  
  146. begin
  147.   if (X < Y)
  148.     then Result := X
  149.     else Result := Y;
  150. end;
  151.  
  152.  
  153. function IntFindMax(X,Y: Integer): Integer;
  154.  
  155. begin
  156.   if (X > Y)
  157.     then Result := X
  158.     else Result := Y;
  159. end;
  160.  
  161.  
  162. procedure Register;
  163. begin
  164.   RegisterComponents('Additional', [TPanelClock]);
  165. end;
  166.  
  167.  
  168. constructor TPanelClock.Create(AOwner: TComponent);
  169.  
  170. begin
  171.   inherited Create(AOwner);
  172.   SetBounds(0,0,219,16);
  173.   Hint := 'Click to see system resources';
  174.   Hint2 := 'Click to see clock';
  175.   FAlertFont := TFont.Create;
  176.   FAlertLevel := 20;
  177.   FAlertMatchFont := TRUE;
  178.   FAllowClick := TRUE;
  179.   FBevel := bvLowered;
  180.   FBevelWidth := 1;
  181.   FClockWidth := 96;
  182.   FSpace := 1;
  183. end;
  184.  
  185.  
  186. procedure TPanelClock.Click;
  187.  
  188. begin
  189.   if (AllowClick)
  190.     then begin
  191.            if (PanelMode = pmClock)
  192.              then PanelMode := pmResources
  193.              else PanelMode := pmClock;
  194.          end;
  195.   inherited Click;
  196. end;
  197.  
  198.  
  199. procedure TPanelClock.Paint;
  200.  
  201. var
  202.   ClientRect: TRect;
  203.   StatusRect: TRect;
  204.   TextMetric: TTextMetric;
  205.   TopColor, BottomColor: TColorRef;
  206.   OldColor, SaveFontColor: TColorRef;
  207.   X: Integer;
  208.   RWidth: Integer;
  209.  
  210. const
  211.   KeyStates: array[1..ksNumberOfKeyStatuses] of String[4] = ('NUM','CAPS','SCRL');
  212.   ResMonitors: array[1..rmNumberOfMonitors] of String[4] = ('GDI:','SYS:','USR:');
  213.  
  214.   procedure PaintRect(ARect: TRect; S: String);
  215.  
  216.   var
  217.     X,Y: Integer;
  218.     W,H: Integer;
  219.     FRect: TRect;
  220.  
  221.   begin
  222.     FRect := ARect;
  223.     if (Bevel <> bvNone)
  224.       then Frame3D(Canvas,ARect,TopColor,BottomColor,BevelWidth);
  225.     W := Canvas.TextWidth(S);
  226.     WinProcs.GetTextMetrics(Canvas.Handle,TextMetric);
  227.     H := TextMetric.tmHeight;
  228.     X := ARect.Left + IntFindMax((ARect.Right - ARect.Left - W) div 2,1);
  229.     Y := ARect.Top + IntFindMax((ARect.Bottom - ARect.Top - H) div 2,1);
  230.     Canvas.TextRect(ARect,X,Y,S);
  231.  
  232.     {Fill up the spacer}
  233.     if (Space > 0) and (FRect.Right + Space <= ClientRect.Right)
  234.       then begin
  235.              FRect.Left := FRect.Right;
  236.              FRect.Right := FRect.Left + Space;
  237.              Canvas.Brush.Color := Self.Color;
  238.              Canvas.FillRect(FRect);
  239.            end;
  240.   end;
  241.  
  242. begin
  243.   inherited Paint;
  244.   ClientRect := GetClientRect;
  245.   if (Bevel = bvLowered)
  246.     then begin
  247.            TopColor := clBtnShadow;
  248.            BottomColor := clBtnHighlight;
  249.          end
  250.     else begin
  251.            TopColor := clBtnHighlight;
  252.            BottomColor := clBtnShadow;
  253.          end;
  254.  
  255.   Canvas.Font := Self.Font;
  256.   FLastPaint := TimeToStr(Time);
  257.   OldColor := SetBkColor(Canvas.Handle,ColorToRGB(Color));
  258.   StatusRect := ClientRect;
  259.   if (PanelMode = pmClock)
  260.     then begin
  261.            StatusRect.Right := IntFindMin(StatusRect.Right,ClockWidth);
  262.            PaintRect(StatusRect,FLastPaint);
  263.            Inc(StatusRect.Left,ClockWidth+Space);
  264.            RWidth := (ClientRect.Right - StatusRect.Left - (Space * ksNumberOfKeyStatuses)) div ksNumberOfKeyStatuses;
  265.            for x := 1 to ksNumberOfKeyStatuses do
  266.              begin
  267.                if (x = ksNumberOfKeyStatuses)
  268.                  then RWidth := ClientRect.Right;
  269.                StatusRect.Right := IntFindMin(StatusRect.Left + RWidth,ClientRect.Right-Space);
  270.                if (StatusRect.Right - StatusRect.Left > (2*BevelWidth))
  271.                  then begin
  272.                         if (((1 shl Pred(x)) and FKeyState) <> 0)
  273.                           then PaintRect(StatusRect,KeyStates[x])
  274.                           else PaintRect(StatusRect,'');
  275.                       end;
  276.                StatusRect.Left := StatusRect.Right + Space;
  277.              end;
  278.          end
  279.     else begin
  280.            if (FAlertMatchFont)
  281.              then begin
  282.                     FAlertFont.Assign(Font);
  283.                     FAlertFont.Color := clRed;
  284.                   end;
  285.  
  286.            RWidth := (ClientRect.Right - ClientRect.Left - (Space * rmNumberOfMonitors)) div rmNumberOfMonitors;
  287.            for x := 1 to rmNumberOfMonitors do
  288.              begin
  289.                if (x = rmNumberOfMonitors)
  290.                  then RWidth := ClientRect.Right;
  291.                StatusRect.Right := IntFindMin(StatusRect.Left + RWidth,ClientRect.Right-Space);
  292.                if (FResources[x] < AlertLevel) and (AlertFont <> NIL)
  293.                  then Canvas.Font := AlertFont
  294.                  else Canvas.Font := Self.Font;
  295.                PaintRect(StatusRect,ResMonitors[x]+IntToStr(FResources[x])+'%');
  296.                StatusRect.Left := StatusRect.Right + Space;
  297.              end;
  298.          end;
  299.  
  300.   SetBkColor(Canvas.Handle,OldColor);
  301. end;
  302.  
  303.  
  304. procedure TPanelClock.SetAlertFont(Value: TFont);
  305.  
  306. begin
  307.   FAlertFont.Assign(Value);
  308.   FAlertMatchFont := FALSE;
  309.   Invalidate;
  310. end;
  311.  
  312.  
  313. procedure TPanelClock.SetAlertLevel(Value: Integer);
  314.  
  315. begin
  316.   if (FAlertLevel <> Value)
  317.     then begin
  318.            FAlertLevel := IntFindMax(IntFindMin(Value,100),0);
  319.            Invalidate;
  320.          end;
  321. end;
  322.  
  323.  
  324. procedure TPanelClock.SetAlertMatchFont(Value: Boolean);
  325.  
  326. begin
  327.   FAlertMatchFont := Value;
  328.   if (Value)
  329.     then begin
  330.            FAlertFont.Assign(Font);
  331.            FAlertFont.Color := clRed;
  332.            Invalidate;
  333.          end;
  334. end;
  335.  
  336.  
  337. procedure TPanelClock.SetBevel(Value: TPanelBevel);
  338.  
  339. begin
  340.   FBevel := Value;
  341.   Invalidate;
  342. end;
  343.  
  344.  
  345. procedure TPanelClock.SetBevelWidth(Value: Integer);
  346.  
  347. begin
  348.   FBevelWidth := Value;
  349.   Invalidate;
  350. end;
  351.  
  352.  
  353. procedure TPanelClock.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
  354.  
  355. begin
  356.   inherited SetBounds(ALeft, ATop, IntFindMax(AWidth,ClockWidth), AHeight);
  357. end;
  358.  
  359.  
  360. procedure TPanelClock.SetClockWidth(Value: Integer);
  361.  
  362. begin
  363.   FClockWidth := Value;
  364.   Invalidate;
  365. end;
  366.  
  367.  
  368. procedure TPanelClock.SetPanelMode(Value: TPanelMode);
  369.  
  370. var
  371.   Msg: TMsg;
  372.   Temp: String;
  373.  
  374. begin
  375.   FillChar(FResources,SizeOf(FResources),0);
  376.   FLastPaint := '';
  377.   if (FPanelMode <> Value)
  378.     then begin
  379.            FPanelMode := Value;
  380.            WMTimer(Msg);
  381.            Temp := Hint;
  382.            Hint := Hint2;
  383.            Hint2 := Temp;
  384.          end;
  385. end;
  386.  
  387.  
  388. procedure TPanelClock.SetSpace(Value: Integer);
  389.  
  390. begin
  391.   FSpace := Value;
  392.   Invalidate;
  393. end;
  394.  
  395.  
  396. procedure TPanelClock.WMDestroy(var Msg: TMsg);
  397.  
  398. begin
  399.   KillTimer(Handle,1);
  400.   inherited
  401. end;
  402.  
  403.  
  404. procedure TPanelClock.WMCreate(var Msg: TMsg);
  405.  
  406. begin
  407.   SetTimer(Handle,1,200,NIL);
  408.   inherited;
  409. end;
  410.  
  411.  
  412. procedure TPanelClock.WMTimer(var Msg: TMsg);
  413.  
  414. var
  415.   NewKeyState: Integer;
  416.   NewResources: TResourceMonitor;
  417.   X: Integer;
  418.  
  419. begin
  420.   NewKeyState := 0;
  421.   if (PanelMode = pmClock)
  422.     then begin
  423.            if (GetKeyState(VK_NUMLOCK) and $01) <> 0
  424.              then Inc(NewKeyState,ksNumLock);
  425.            if (GetKeyState(VK_CAPITAL) and $01) <> 0
  426.              then Inc(NewKeyState,ksCapsLock);
  427.            if (GetKeyState(VK_SCROLL) and $01) <> 0
  428.              then Inc(NewKeyState,ksScrollLock);
  429.            if (FLastPaint <> TimeToStr(Time)) or (FKeyState <> NewKeyState)
  430.              then begin
  431.                     FKeyState := NewKeyState;
  432.                     Paint;
  433.                   end;
  434.          end
  435.     else begin
  436.            NewResources[rmGDIResources] := GetFreeSystemResources(GFSR_GDIResources);
  437.            NewResources[rmSystemResources] := GetFreeSystemResources(GFSR_SystemResources);
  438.            NewResources[rmUserResources] := GetFreeSystemResources(GFSR_UserResources);
  439.            for x := 1 to rmNumberOfMonitors do
  440.              if (NewResources[x] <> FResources[x])
  441.                then begin
  442.                       Move(NewResources,FResources,SizeOf(FResources));
  443.                       Paint;
  444.                       Break;
  445.                     end;
  446.          end;
  447.   inherited;
  448. end;
  449.  
  450. end.
  451.